home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / Examples / edit-definition-patch.lisp < prev    next >
Encoding:
Text File  |  1993-02-01  |  20.6 KB  |  466 lines  |  [TEXT/CCL2]
  1. ;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;; edit-definition-patch.lisp
  4. ;;copyright © 1992, 1993, Apple Computer, Inc.
  5. ;;
  6. ;;
  7. ;;   Make edit-definition (meta-.) on a method with specializers 
  8. ;;   find all the applicaple methods sorted by applicability
  9. ;;
  10. ;;
  11. ; Notes:
  12. ; :primary in qualifier position means just primary
  13. ; no qualifier means all
  14. ; Also includes patch to edit-definition-spec-lessp for edit-callers
  15. ; make dialog do the same as meta-.
  16.  
  17. ;10/27/92 fix edit-definition-p when given a method-function
  18. ; 06/22/92 clean up a bit, make error report less verbose and clearer
  19. ; 06/17/92 fix definition-spec-lessp for (setf ..), show which are setf when both
  20.  
  21. (in-package :ccl)
  22.  
  23. (defvar *ed-show-setf* nil)
  24.  
  25. (let ((*warn-if-redefine* nil)
  26.       (*warn-if-redefine-kernel* nil))
  27.  
  28. ; modified version of %compute-applicable-methods*
  29. ; omit errors and args are class names not instances
  30. (defun find-applicable-methods (name args qualifiers)
  31.   (let ((gf (fboundp name)))
  32.     (when (and gf (typep gf 'standard-generic-function))
  33.       (let* ((methods (%gf-methods gf))
  34.              (args-length (length args))
  35.              (bits (lfun-bits gf))
  36.              arg-count res)
  37.         (when methods
  38.           (setq arg-count (length (%method-specializers (car methods))))
  39.           (unless (or (logbitp $lfbits-rest-bit bits)
  40.                       (logbitp $lfbits-keys-bit bits)
  41.                       (<= args-length 
  42.                           (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits))))
  43.             (return-from find-applicable-methods))
  44.           (let ((cpls (make-list arg-count)))
  45.             (declare (dynamic-extent cpls))
  46.             (do ((args-tail args (cdr args-tail))
  47.                  (cpls-tail cpls (cdr cpls-tail)))
  48.                 ((null cpls-tail))
  49.               (let ((arg (car args-tail)) thing)
  50.                 (if (consp arg)
  51.                   (setq thing (class-of (cadr arg)))
  52.                   (setq thing (find-class (or arg t))))
  53.                 (setf (car cpls-tail)                
  54.                       (%class-precedence-list thing))))
  55.             (dolist (m methods)
  56.               (if 
  57.                 (and (or (eq qualifiers t)
  58.                          (equal qualifiers (%method-qualifiers m)))
  59.                      (%my-method-applicable-p m args cpls))
  60.                 (push m res)))
  61.             (let ((methods (sort-methods res cpls (%gf-precedence-list gf))))
  62.               (if (eq (ccl::generic-function-method-combination gf)
  63.                       ccl::*standard-method-combination*)
  64.                 (let (arounds befores primaries afters)
  65.                   (dolist (method methods)
  66.                     (case (car (method-qualifiers method))
  67.                       (:before (push method befores))
  68.                       (:after (push method afters))
  69.                       (:around (push method arounds))
  70.                       (t (push method primaries))))
  71.                   (nconc (nreverse arounds)
  72.                          (nreverse befores)
  73.                          (nreverse primaries)
  74.                          afters))
  75.                 methods)))))))) 
  76.  
  77. ; modified version of %method-applicable-p - args are class names not instances
  78. (defun %my-method-applicable-p (method args cpls)
  79.   (do ((specs (%method-specializers method) (cdr specs))
  80.        (args args (cdr args))
  81.        (cpls cpls (cdr cpls)))
  82.       ((null specs) t)
  83.     (let ((spec (car specs)))
  84.       (if (listp spec)
  85.         (unless (equal (car args) spec)
  86.           (return nil))
  87.         (unless (or (eq (caar cpls) (find-class t))
  88.                     (memq spec (car cpls)))
  89.           (return nil))))))
  90.  
  91. (defun parse-definition-spec (form)
  92.   (let ((type t)
  93.         name classes qualifiers)
  94.     (cond
  95.      ((consp form)
  96.       (cond ((eq (car form) 'setf)
  97.              (setq name form))
  98.             (t (setq name (car form))
  99.                (let ((last (car (last (cdr form)))))
  100.                  (cond ((and (listp last)(or (null last)(neq (car last) 'eql)))
  101.                         (setq classes last)
  102.                         (setq qualifiers (butlast (cdr form))))
  103.                        (t (setq classes (cdr form)))))                   
  104.                (cond ((null qualifiers)
  105.                       (setq qualifiers t))
  106.                      ((equal qualifiers '(:primary))
  107.                       (setq qualifiers nil))))))
  108.      (t (setq name form)))
  109.     (when (and (consp name)(eq (car name) 'setf))
  110.         (setq name (or (%setf-method (cadr name)) name))) ; e.g. rplacd
  111.     (when (consp qualifiers)
  112.       (mapc #'(lambda (q)
  113.                 (when (listp q)
  114.                   (return-from parse-definition-spec)))
  115.           qualifiers))
  116.     (when classes
  117.       (mapc #'(lambda (c)
  118.                 (when (not (and c (or (symbolp c)(and (consp c)(eq (car c) 'eql)))))
  119.                   (return-from parse-definition-spec)))
  120.             classes))            
  121.     (when (or (consp classes)(consp qualifiers))(setq type 'method))
  122.     (values type name classes qualifiers)))
  123.  
  124.  
  125.  
  126. (defmethod ed-edit-definition ((w fred-mixin) &optional pos)
  127.   (let ((form (ignore-errors (ed-current-sexp w pos))))
  128.     (cond
  129.      ((null form)
  130.       (edit-definition-dialog))
  131.      (t (edit-definition-spec form)))))
  132.  
  133. (defun edit-definition-spec (form)
  134.   (multiple-value-bind (pos files name type classes qualifiers)
  135.                        (edit-definition form)
  136.     (cond (name
  137.            (when (and (not pos)(not files))            
  138.              ; if no source file info - search all buffers?
  139.              (dolist (ww (windows))
  140.                (when (and
  141.                       (typep ww 'fred-window)
  142.                       (not (typep ww 'listener)))
  143.                  (setq pos (search-for-def (fred-buffer ww) name type classes qualifiers))
  144.                  (when pos
  145.                    (window-select ww)
  146.                    (ed-push-mark ww)
  147.                    (window-scroll ww pos)
  148.                    (return))))
  149.              (when (not pos)
  150.                (edit-definition-error name classes qualifiers nil))))
  151.           (t (let ((*print-length* 3)(*print-level* 2))
  152.                (ed-beep)
  153.                (format t "~S not understood by edit definition." form))))))
  154.  
  155. (defun edit-definition-error (name classes qualifiers file)
  156.   (ed-beep)
  157.   (when (eq t qualifiers)(setq qualifiers nil))
  158.   (let ((*print-length* 3)(*print-level* 2))
  159.     (if file
  160.       (format t "Can't find ~s~@[ with specializers ~s~]~@[ qualifers ~s~] in file ~s."
  161.             name classes qualifiers file)
  162.       (format t "There is no source file information for ~s~@[ with specializers ~s~]~@[ qualifers ~s~]."
  163.               name classes qualifiers))))
  164.  
  165. (defun get-source-files-with-types&classes (sym &optional (type t) classes qualifiers the-method)
  166.   (labels 
  167.     ((merge-types (l)
  168.        (let ((ftype (car l)))
  169.          (cond
  170.           ((eq ftype 'setf)
  171.            (mapcan #'merge-types (cdr l)))
  172.           ((or (eq type t)(eq ftype type))
  173.            (let* ((foo #'(lambda (x)
  174.                            (when x
  175.                              ; if x is consp it's (<method> file file ..)
  176.                              (cond 
  177.                               ((consp x)
  178.                                (when (or (not (or classes qualifiers))
  179.                                          (if the-method 
  180.                                            (methods-match-p (car x) the-method)
  181.                                            (source-files-like-em classes qualifiers
  182.                                                                  (car x))))
  183.                                  (merge-class x)))
  184.                               (t (list (cons ftype x))))))))
  185.              (declare (dynamic-extent foo))
  186.              (mapcan foo (if (consp (cdr l)) (cdr l)(list (cdr l)))))))))
  187.      (merge-class (l)
  188.        (if (consp (cdr l))
  189.          (mapcan 
  190.           #'(lambda (x) 
  191.               (when x (list (cons (car l) x))))
  192.           (cdr l))
  193.          (list l))))
  194.     (declare (dynamic-extent #'merge-types))
  195.     (let (files)
  196.       (when (and (not the-method)(eq type 'method))
  197.         (let ((methods (find-applicable-methods sym classes qualifiers)))
  198.           (when methods
  199.             (setq files (mapcan
  200.                          #'(lambda (m)
  201.                              (edit-definition-p m))
  202.                          methods)))))      
  203.       (if files files
  204.           (let (setf-p result)
  205.             (if (and (consp sym)(eq (car sym) 'setf))
  206.               (setq sym (cadr sym) setf-p t))
  207.             (setq result (%source-files sym))
  208.             (if (not (consp result))
  209.               (setq result
  210.                     (if (not setf-p)
  211.                       (if (or (eq type t)(eq type 'function))
  212.                         `((function . ,result)))))
  213.               (if setf-p (setq result (list (assq 'setf result)))))
  214.             (mapcan #'merge-types result))))))
  215.  
  216. ; we need this because callers can find a method which is not the current def
  217. ; (i.e. its really garbage)
  218. ; why don't we get the right one instead - then we can use eq again??
  219. ; Oh well leave it just in case record source file gets confused.
  220. (defun methods-match-p (x y)  
  221.   (or (eq x y)
  222.       (and (typep x 'method)
  223.            (typep y 'method)
  224.            (equal (method-name x)
  225.                   (method-name y))
  226.            ; this is not  right for eql methods with non-constant frobs
  227.            (equal (method-specializers x)
  228.                   (method-specializers y))
  229.            (equal (method-qualifiers x)
  230.                   (method-qualifiers y)))))
  231.  
  232. (defun edit-definition-p (name &optional (type t) &aux specializers qualifiers the-method)
  233.   (when (consp name)
  234.     (multiple-value-setq (type name specializers qualifiers)
  235.       (parse-definition-spec name)))
  236.   (when (and specializers (consp specializers)) (setq type 'method))
  237.   (typecase name
  238.     (method
  239.      (setq qualifiers (%method-qualifiers name)
  240.            specializers (mapcar #'(lambda (s)
  241.                                     (if (consp s) s (class-name s)))
  242.                                 (%method-specializers name))
  243.            the-method name
  244.            name (%method-name name)
  245.            type 'method))
  246.     (function 
  247.      (return-from edit-definition-p 
  248.        (edit-definition-p (function-name name) type))))
  249.   (let (files str newname)    
  250.     (setq files (or (get-source-files-with-types&classes name type specializers qualifiers the-method)
  251.                     (and 
  252.                      (not the-method)
  253.                      (symbolp name)
  254.                      (or (and
  255.                           (setq str (symbol-name name))
  256.                           (memq (schar str (1- (length str))) '(#\.  #\, #\:))
  257.                           (setq newname
  258.                                 (find-symbol (%substr str 0 (1- (length str)))
  259.                                              (symbol-package name)))
  260.                           (get-source-files-with-types&classes newname type specializers qualifiers))
  261.                          (let ((syms (find-all-symbols name)))
  262.                            (do ((lst syms (cdr lst))
  263.                                 (val nil))
  264.                                ((null lst) nil)
  265.                              (when (and (neq (car lst) name)
  266.                                         (setq val 
  267.                                               (get-source-files-with-types&classes
  268.                                                (car lst) type specializers qualifiers)))
  269.                                (setq newname (car lst))
  270.                                (return val))))))))         
  271.   (multiple-value-bind (ipath itype) (interface-definition-p name type)
  272.     (when (and ipath (not (member (pathname-name ipath) files 
  273.                                   :key #'(lambda (x) (pathname-name (cdr x))) :test 'equal)))
  274.       (push (cons itype ipath) files)))
  275.   (when (and files newname) (setq name newname))
  276.   (values files name type specializers qualifiers)))
  277.  
  278.  
  279. (defun format-definition-pathnames (object &optional (stream t))
  280.   (let ((thing (car object))
  281.         (path (cdr object))
  282.         (fstr "<~s ~s>"))
  283.     (if (typep thing 'standard-method)
  284.       (progn
  285.         (if (and *ed-show-setf* (consp (method-name thing)))
  286.           (setq fstr"<SETF ~s ~s>"))
  287.         (let ((qualifiers (%method-qualifiers thing)))
  288.           (format stream fstr (case (length qualifiers)
  289.                                      (0 :primary)
  290.                                      (1 (car qualifiers))
  291.                                      (t qualifiers))
  292.                   (mapcar #'(lambda (class)
  293.                               (if (consp class)
  294.                                 class
  295.                                 (or (class-name class) class)))
  296.                           (%method-specializers thing)))))
  297.       (format stream "~s" thing))
  298.     (when (or (stringp path) (pathnamep path))
  299.       (format stream " ~s" (pathname-to-window-title path)))))
  300.  
  301. (defun edit-definition (name &optional (type t))
  302.   (multiple-value-bind (files name type classes qualifiers)
  303.                        (edit-definition-p name type)
  304.     (declare (ignore-if-unused type))
  305.     (if (not files)
  306.       (values nil nil name type classes qualifiers)
  307.       (cond ((null (cdr files))
  308.              (let ((pos (edit-definition-2 (car files) name)))
  309.                (values pos files name type classes qualifiers)))
  310.             (t 
  311.              (let* ((ed-show-setf
  312.                      (dolist (f files)
  313.                        (let ((thing (car f)))                              
  314.                          (when (and (typep thing 'method)
  315.                                     (consp (setq thing (method-name thing)))
  316.                                     (not (equal thing name)))
  317.                            (return t)))))
  318.                     w)
  319.                (setq w
  320.                      (select-item-from-list
  321.                       (if classes ; already sorted by applicability (true always?)
  322.                         files                        
  323.                         (setq files (sort files #'edit-definition-spec-lessp :key #'car)))
  324.                       :table-print-function #'(lambda (a &optional (b t))
  325.                                                 (let ((*ed-show-setf* ed-show-setf))
  326.                                                   (format-definition-pathnames a b)))
  327.                       :window-title              
  328.                       (format nil "Definitions of ~S." name)
  329.                       :modeless t
  330.                       :default-button-text "Find it"
  331.                       :action-function
  332.                       #'(lambda (list)
  333.                           (if (option-key-p) (window-close w))
  334.                           (edit-definition-2 (car list) name))))
  335.                (values t files name type classes qualifiers)))))))
  336.  
  337. (defun edit-definition-2 (pathname name)
  338.   ; pathname isn't. Car is 'variable, a method, 'function, 'class etc.
  339.   ; Cdr is the pathname. - only called if source file info
  340.   (let (type pos new-window classes qualifiers)
  341.     (when pathname
  342.       (setq type (car pathname)
  343.             pathname (or (cdr pathname) "New"))
  344.       (typecase type
  345.         (method
  346.          (setq qualifiers (%method-qualifiers type)
  347.                classes (mapcar #'(lambda (s)
  348.                                    (if (consp s) s (class-name s)))
  349.                                (%method-specializers type))
  350.                name (%method-name type)
  351.                type 'method)))
  352.       (setq new-window 
  353.             (or (pathname-to-window pathname)
  354.                 (and (stringp pathname)                       
  355.                      ; does it look like a real pathname ?
  356.                      (equalp pathname "New")
  357.                      ; No, pick a random fred window that has no pathname
  358.                      (my-string-to-window pathname))))
  359.       (if new-window
  360.         (window-select new-window)
  361.         (setq new-window (ed pathname)))
  362.       (let ((buf (fred-buffer new-window)))
  363.         (setq pos (or (search-for-def buf name type classes qualifiers)
  364.                       ; ? do we really want to do this ?
  365.                       (search-for-def-dumb buf name type classes qualifiers
  366.                                            0 (buffer-size buf) T)))) ; and dumber
  367.       (when pos
  368.         (ed-push-mark new-window)
  369.         (window-scroll new-window pos)))
  370.     (when (not pos)(edit-definition-error name classes qualifiers pathname))
  371.     (values pos pathname)))
  372.  
  373. ; slight tweak to make it applicable for edit callers
  374. (defun edit-definition-spec-lessp (x y)
  375.   (cond ((symbolp x)
  376.          (if (symbolp y) (string-lessp x y) t))
  377.         ((symbolp y) nil)
  378.         ((typep x 'standard-method)
  379.          (if (typep y 'standard-method)
  380.            (let ((y-name (method-name y))
  381.                  (x-name (method-name x)))             
  382.              (if (not (equal x-name y-name))
  383.                (progn
  384.                  (if (consp x-name)(setq x-name (format nil "~A" x-name)))
  385.                  (if (consp y-name)(setq y-name (format nil "~A" y-name)))
  386.                  (string-lessp x-name y-name))
  387.                (let ((y-specs (method-specializers y))
  388.                      y-spec)
  389.                  (dolist (x-spec (method-specializers x)
  390.                                  (or y-specs
  391.                                      (let ((y-qs (method-qualifiers y))
  392.                                            y-q)
  393.                                        (dolist (x-q (method-qualifiers x) y-qs)
  394.                                          (unless y-qs (return nil))
  395.                                          (setq y-q (pop y-qs))
  396.                                          (cond ((string-lessp x-q y-q)
  397.                                                 (return t))
  398.                                                ((string-lessp y-q x-q)
  399.                                                 (return nil)))))))
  400.                    (unless y-specs (return nil))
  401.                    (setq y-spec (pop y-specs))
  402.                    (if (typep x-spec 'class)
  403.                      (if (typep y-spec 'class)
  404.                        (let ((x-name (class-name x-spec))
  405.                              (y-name (class-name y-spec)))
  406.                          (if (edit-definition-spec-lessp x-name y-name)
  407.                            (return t))
  408.                          (if (edit-definition-spec-lessp y-name x-name)
  409.                            (return nil)))
  410.                        (return nil))
  411.                      t)))))
  412.            t))
  413.         ((typep y 'standard-method) nil)
  414.         (t (< (%address-of x) (%address-of y)))))
  415.  
  416. (defun search-for-def-dumb (w target type classes qualifiers pos end &optional dumber)  
  417.    (when (null (stringp target))
  418.      (setq target (if (symbolp target) (symbol-name target)(format nil "~A" target)))
  419.      (when (eq type 'structure)(setq target (%str-cat "(" target))))
  420.   (let ((target-length (length target))
  421.         result)
  422.     (while (and pos (< pos end))
  423.       (setq pos (buffer-forward-search w "(def" pos end))
  424.       (when pos
  425.         (let* ((defstart (- pos 4))
  426.                (after-d-e-f pos)
  427.                (defend (buffer-fwd-symbol w (1- after-d-e-f) end)))
  428.           (setq pos (buffer-skip-fwd-wsp&comments w defend end))
  429.           (when (and (setq pos (buffer-delimited-substring-p w target pos end target-length))
  430.                      (or (= defstart 0)
  431.                          ; at least avoid finding (let ((def (blah))))
  432.                          (memq (buffer-char w (1- defstart)) '(#\newline #\space)))
  433.                      (or (neq type 'method)
  434.                          (search-method-classes w classes qualifiers pos end)))
  435.             (setq result defstart))
  436.           (setq pos defend))))
  437.     (or result (when dumber
  438.                  (setq result 0)
  439.                  (while (setq result (buffer-forward-search w target result end))
  440.                    (when  (%str-member  (buffer-char w result) symbol-specials)
  441.                      (return-from search-for-def-dumb (- result target-length))))))))
  442.  
  443. ; from ccl-menus
  444. (defun edit-definition-dialog (&aux (initial-string %edit-definition-string))
  445.   (let ((w (front-window)))
  446.     (when (and w (typep w 'fred-window))
  447.       (multiple-value-bind (b e)(selection-range w)
  448.         (when (neq b e)(setq %edit-definition-string (buffer-substring (fred-buffer w) b e))))))
  449.   (if (and *edit-definition-dialog*
  450.            (wptr *edit-definition-dialog*))
  451.     (window-select *edit-definition-dialog*)                             
  452.     (setq *edit-definition-dialog*
  453.           (get-string-from-user
  454.            "Enter the name of a symbol. The definition (if there is one) will be found, or a list of choices will be shown."
  455.            :window-title "Edit Definition"
  456.            :initial-string initial-string
  457.            :modeless t
  458.            :action-function
  459.            #'(lambda (new-string)
  460.                (let (sym)
  461.                  (unless (equal new-string "")
  462.                    (setq sym (read-from-string new-string))
  463.                    (edit-definition-spec sym)
  464.                    (setq %edit-definition-string new-string))))))))
  465.  
  466. )